home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1992 June: ROMin Holiday / ADC Developer CD (1992-06) (''ROMin Holiday'')_iso / Developer Connection - 06-1992.iso / Development Platforms / LISP Related / MCL Utilities / MultiFinder-Friendly.lisp next >
Encoding:
Text File  |  1990-09-04  |  1.6 KB  |  35 lines  |  [TEXT/CCL ]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;; Copyright 1989, 1990 by Ruben Kleiman for Apple Computer, Inc.
  3. ;;; Advanced Technology Group
  4. ;;;
  5.  
  6. ;;;
  7. ;;; MultiFinder friendly hack.
  8. ;;; This hack ensures that Lisp code that runs while Macintosh Allegro Common Lisp
  9. ;;; is in the background executes in a MultiFinder friendly manner.
  10. ;;; This hack works in MACL 1.3.  The main effect is to reduce the overhead
  11. ;;; when your code is executing in the background, ensuring maximum
  12. ;;; time for the foreground task.
  13.  
  14. ;;;
  15. ;;; The usage is:  (in-multifinder-background <form>*)
  16. ;;;
  17.  
  18. (defparameter $CurrentA5 #x904)    ; A5 GLOBAL ADDRESS
  19. (defparameter *inest-ptr* (%inc-ptr (%get-ptr $currentA5) #x-106))  ; A5 OFFSET TO CURRENT INTERRUPT LEVEL
  20.  
  21. ;;; WRAP AROUND FOR CODE THAT YOU WANT TO EVALUATE WHILE IN MACL
  22. ;;; IS IN THE MULTIFINDER BACKGROUND:  THIS WILL MAKE MACL MULTIFINDER FRIENDLY
  23. (defmacro in-multifinder-background (&body body)
  24.   (let ((old-level (gensym))  ; TO RESET OLD INTERRUPT LEVEL
  25.         (result (gensym)))    ; RESULT OF EVALUATING BODY
  26.     `(let ((,old-level (%get-signed-word *inest-ptr*))   ; GET CURRENT INTERRUPT LEVEL
  27.            ,result
  28.            (*processing-events* nil))                    ; DON'T HANDLE ANY OTHER EVENTS!
  29.        (unwind-protect
  30.          (progn
  31.            (%put-word *inest-ptr* 0)                     ; SET NEW INTERRUPT LEVEL
  32.            (setq ,result ,(cons 'PROGN body)))           ; EVAL BODY
  33.          (%put-word *inest-ptr* ,old-level)              ; RESET TO OLD INTERRUPT LEVEL
  34.          ,result))))                                     ; RETURN RESULT
  35.